home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / oper_sys / fp / ifp_unix.lzh / ifp / interp / xdef.c < prev   
Encoding:
C/C++ Source or Header  |  1989-05-23  |  5.4 KB  |  227 lines
  1.  
  2. /****** xdef.c ********************************************************/
  3. /**                                                                  **/
  4. /**                    University of Illinois                        **/
  5. /**                                                                  **/
  6. /**                Department of Computer Science                    **/
  7. /**                                                                  **/
  8. /**   Tool: IFP                         Version: 0.5                 **/
  9. /**                                                                  **/
  10. /**   Author:  Arch D. Robison          Date:   Aug 4, 1986          **/
  11. /**                                                                  **/
  12. /**   Revised by: Arch D. Robison       Date:   Aug 4, 1986          **/
  13. /**                                                                  **/
  14. /**   Principal Investigators: Prof. R. H. Campbell                  **/
  15. /**                            Prof. W. J. Kubitz                    **/
  16. /**                                                                  **/
  17. /**                                                                  **/
  18. /**------------------------------------------------------------------**/
  19. /**   (C) Copyright 1987  University of Illinois Board of Trustees   **/
  20. /**                       All Rights Reserved.                       **/
  21. /**********************************************************************/
  22.  
  23. /************************* Extended Definitions ************************/
  24.  
  25. #include <stdio.h>
  26. #include "struct.h"
  27. #include "node.h"
  28. #include "inob.h"
  29.  
  30. #if XDEF
  31.  
  32. ListPtr Environment = NIL;
  33.  
  34. /*
  35.  * OutLHS
  36.  *
  37.  * Input
  38.  *      P = LHS to output
  39.  */
  40. void OutLHS (InOut)
  41.    ObjectPtr InOut;
  42.    {
  43.       switch (InOut->Tag) {
  44.      case LIST: {
  45.         register ListPtr P=InOut->List;
  46.         printf ("[");
  47.         if (P!=NIL)
  48.            while (1) {
  49.           if (Debug & DebugRef) printf ("{%d}",P->LRef + (1 - LRefOne));
  50.           OutLHS (& P->Val);
  51.           if ((P=P->Next) == NULL) break; 
  52.           else printf (",");
  53.            }
  54.         printf ("]");
  55.         break;
  56.      }
  57.      default: OutObject (InOut);
  58.       }
  59.    }
  60.  
  61. /*
  62.  * Assign
  63.  *
  64.  * Assign functional variables.
  65.  *
  66.  * Input
  67.  *    X = object to be matched with LHS.
  68.  *    F = LHS
  69.  */
  70. private boolean Assign (X,F)
  71.    ObjectPtr X,F;
  72.    {
  73.       register ListPtr P,Q;
  74.       extern StrPtr CopySPtr();
  75.  
  76.       switch (F->Tag) {
  77.  
  78.      case STRING:
  79.         NewList (&Environment,2L);
  80.         P = Environment;
  81.         P->Val.Tag = STRING;
  82.         P->Val.String = CopySPtr (F->String);
  83.         CopyObject (&P->Next->Val,X);
  84.         return 1;
  85.  
  86.      case LIST:
  87.         if (X->Tag != LIST) return 0;
  88.         else {
  89.            for (Q=X->List,P=F->List; P!=NULL; Q=Q->Next,P=P->Next) 
  90.           if (Q==NULL || !Assign (&Q->Val,&P->Val)) return 0;
  91.            return 1;
  92.         }
  93.  
  94.      default: 
  95.         return 0;
  96.       } 
  97.    }
  98.  
  99. /*
  100.  * FF_XDef
  101.  *
  102.  * Apply function F to each element of list InOut
  103.  *
  104.  * Input
  105.  *      InOut = list of elements to apply function
  106.  *      Funs = <lhs rhs function>
  107.  *
  108.  * Output
  109.  *      InOut = result
  110.  */
  111. FF_XDef (InOut,Funs)
  112.    ObjectPtr InOut;
  113.    register ListPtr Funs;
  114.    {
  115.       ListPtr P;
  116.       Object X;
  117.       boolean InRange;
  118.  
  119.       if (3L != ListLength (Funs)) {
  120.      FormError (InOut,"invalid xdef",NULL,Funs);
  121.      return;
  122.       }
  123.       CopyObject (&X,InOut);
  124.       Apply (&X,&Funs->Next->Val);
  125.       P = Environment;
  126.       InRange = Assign (&X,&Funs->Val);
  127.       RepTag (&X,BOTTOM);
  128.       if (InRange) 
  129.      Apply (InOut,&Funs->Next->Next->Val);
  130.       else if (PrintErr (InOut)) {
  131.      OutLHS (&Funs->Val);
  132.      printf (": domain error\n");
  133.      OutObject (InOut);
  134.      printf ("\n");
  135.      RepTag (InOut,BOTTOM);
  136.       }
  137.       RepLPtr (&Environment,P);
  138.    }
  139.  
  140. /*
  141.  * InLHSC
  142.  * 
  143.  * Input
  144.  *     F = input descriptor pointing to '['
  145.  *
  146.  * Output
  147.  *     result = true iff no error occurs
  148.  *     *X = sequence, or unchanged if error occurs.
  149.  */
  150. private boolean InLHSC (F,X,Env)
  151.    register InDesc *F;
  152.    ObjectPtr X;
  153.    ListPtr *Env;
  154.    {
  155.       register MetaPtr A;
  156.       ListPtr R;
  157.  
  158.       *(A = &R) = NULL;
  159.       F->InPtr++; 
  160.       InBlanks (F);
  161.   
  162.       while (']' != *F->InPtr) {
  163.      if (!*F->InPtr) {
  164.         DelLPtr (R);
  165.         return InError (F,"unfinished construction");
  166.      }
  167.      NewList (A,1L);
  168.      if (SysError || !InLHS (F,&(*A)->Val,Env)) {
  169.         DelLPtr (R);
  170.         return 0;
  171.      }
  172.      A = & (*A)->Next;
  173.      if (*F->InPtr == ',') {
  174.         F->InPtr++;
  175.         InBlanks (F);
  176.      }
  177.       }
  178.       F->InPtr++;              /* Skip closing ']' */
  179.       InBlanks (F);
  180.       RepTag (X,LIST);
  181.       X->List = R;
  182.       return 1;
  183.    }
  184.  
  185. /*
  186.  * InLHS
  187.  *
  188.  * Read a left-hand-side of a functional variable definition.
  189.  * Return true iff no error occurred.
  190.  *
  191.  * Input
  192.  *      *F = input descriptor pointing to LHS
  193.  *
  194.  * Output
  195.  *      *F = input descriptor pointing to next token
  196.  *      *Lhs = left hand side    
  197.  *    *Env = list of functional variables in LHS
  198.  *
  199.  * A SysError may occur, in which case X is unchanged.
  200.  */
  201. boolean InLHS (F,LHS,Env)
  202.    register InDesc *F;
  203.    register ObjectPtr LHS;
  204.    ListPtr *Env;
  205.    {
  206.       register ListPtr P;
  207.  
  208.       if (Debug & DebugParse) printf ("InLHS: %s",F->InPtr);
  209.       
  210.       if (*F->InPtr == '[') return InLHSC (F,LHS,Env);
  211.       else {
  212.      if (NULL == InString (F,LHS,NodeDelim,0)) 
  213.         return InError (F,"variable name expected");
  214.      for (P= *Env; P!=NULL; P=P->Next)
  215.         if (ObEqual (&P->Val,LHS)) 
  216.            return InError (F,"redefinition of variable (to left of caret)");
  217.      NewList (Env,1L);
  218.      CopyObject (&(*Env)->Val,LHS);
  219.      return 1;
  220.       }
  221.    }
  222.  
  223. #endif /* XDEF */
  224.  
  225. /******************************* end of xdef.c *******************************/
  226.  
  227.